unit core;

interface

uses classes, sysutils, vm;

procedure forth_evalword(vm:TKsanaForthVM);
procedure forth_tick(vm:TKsanaForthVM);
procedure forth_dotname(vm:TKsanaForthVM);
procedure forth_iscode(vm:TKsanaForthVM);
procedure forth_align(vm:TKsanaForthVM);
procedure corewords(vm:TKsanaForthVM);


implementation

uses stack,structure,memory,arithmetic,compiler,io,osbind;


// get a word from delimitered  by char on tos, and push the str to stack
procedure forth_evalword(vm:TKsanaForthVM);
var str:pchar; count:integer; wname:array [0..255] of char;
begin count:=vm.pop; str:=pchar(vm.pop);
  if count>255 then count:=255;
  strLcopy(wname,str,count);
  vm.evalword(wname);
end;

procedure forth_debug(vm:TKsanaForthVM);
begin
  vm.debug;
end;

procedure forth_bdebug(vm:TKsanaForthVM);
begin
  vm.debug;
end;

procedure forth_find(vm:TKsanaForthVM);
var
  c:integer;
  s:string;
  theword:TForthWord;
begin
  c:=vm.pop;
  s:=pchar(vm.tos);
  s:=copy(s,1,c);
  s:=trim(s);
  theword:=vm.findword(s);
  if assigned(theword) then begin
    vm.tos:=theword.address;
  end else begin
    vm.tos:=0;
  end;
end;

procedure forth_execute(vm:TKsanaForthVM);
var
  addr:cardinal;
begin
  addr:=vm.pop;
  if addr<> 0 then begin
    vm.rpush(vm.ip);
    vm.execword(addr);
  end;
end;

{procedure forth_nameto(vm:TKsanaForthVM);
var p:tKsanaForthWord;
begin p:=tKsanaForthWord(vm.tos);
      if assigned(p.code) then
           vm.tos:=integer(p.code)
      else vm.tos:=integer(p.cfa);
end;}

procedure forth_tick(vm:TKsanaForthVM);
var
 theword:TForthword;
 s:string;
begin s:=vm.zword;
    theword:=vm.findword(s);
    if theword=nil then begin
       vm.error(' ? '+s); forth_abort(vm); exit;
    end;
    vm.push(theword.address) ;
end;

procedure forth_toname(vm:TKsanaForthVM);
var token:cardinal; p:pchar;
begin token:=vm.tos;
      p:=vm.token2name(token);
      vm.tos:=integer(p); //// sam 20100729
end;

procedure forth_tolink(vm:TKsanaForthVM);
var token:cardinal; theword:tforthword;
begin token:=vm.tos;
      theword:=vm.token2word(token);
      if (theword=nil) or (theword.link=nil) then vm.tos:=0
      else vm.tos:=(theword.link).address; //// sam 20100729
end;

procedure forth_dotname(vm:TKsanaForthVM);
begin forth_toname(vm);
      forth_ztype(vm);
end;

procedure forth_bcompile(vm:TKsanaForthVM);
begin forth_tick(vm); vm.compilecell(integer(vm.pop));
end;
{
procedure forth_forget(vm:TKsanaForthVM);
begin
  forth_tick(vm); if vm.aborting then exit; vm.forget(vm.pop);
end;
}
procedure forth_last(vm:TKsanaForthVM);
begin vm.push(vm.lastwordcfa);
end;
procedure forth_dotlast(vm:TKsanaForthVM);
begin
  forth_last(vm);
  forth_dotname(vm);
end;
procedure forth_bye(vm:TKsanaForthVM);
begin
  vm.quiting:=true;
end;
procedure forth_esc(vm:TKsanaForthVM);
begin
  vm.tickinputcheck(vm);
  vm.push(vm.esc); vm.esc:=0;
end;

procedure forth_quitifmissing(vm:TKsanaForthVM);
var
  s:string;
  theword:TForthWord;
begin
  s:=vm.zword;
  theword:=vm.findword(s);
  if theword=nil then vm.quiting :=true;
end;

procedure forth_iscode(vm:TKsanaForthVM);
var
  address:integer;
begin
  address:=vm.pop;
  vm.push(integer(vm.iscodeword(address)));
end;

procedure forth_depth(vm:TKsanaForthVM);
begin
  vm.push(vm.sp+1);
end;
procedure forth_align(vm:TKsanaForthVM);
begin vm.tos:=align(vm.tos);
end;
procedure forth_fence(vm:TKsanaForthVM);
begin vm.push(vm.fence);
end;
procedure forth_iforget(vm:TKsanaForthVM);
var i:integer;
begin i:=vm.tos;
   vm.tos:=integer(vm.iforget(i));
end;
procedure forth_pforget(vm:TKsanaForthVM); // ( cfa -- f )
var cfa,i:integer; theword:tforthword;
begin cfa:=vm.tos;
   vm.tos:=0;
   for i:=vm.words.count-1 downto 0 do begin
       theword:=tforthword(vm.words.objects[i]);
       if theword.address=cardinal(cfa) then break;
   end;
   if i<0 then exit;
   if not vm.iforget(i) then exit;
   vm.tos:=1;
end;
procedure forth_forget(vm:TKsanaForthVM);
var n:string; i:integer; theword:tforthword;
begin n:=vm.zword;
      theword:=vm.findword(n);
      if theword=nil then exit;
      i:=vm.words.IndexOfObject(tobject(theword));
      vm.iforget(i);
end;
procedure forth_anew(vm:TKsanaForthVM);
begin vm.push(integer(vm.ptib));
      forth_forget(vm);
      vm.ptib:=pchar(vm.pop);
      forth_create(vm);
end;
{
procedure forth_setuser1(vm:TKsanaForthVM);
begin
  vm.user1:=vm.pop;
end;

procedure forth_setuser2(vm:TKsanaForthVM);
begin
  vm.user2:=vm.pop;
end;
procedure forth_setuser3(vm:TKsanaForthVM);
begin
  vm.user3:=vm.pop;
end;

procedure forth_getuser1(vm:TKsanaForthVM);
begin
  vm.push(vm.user1);
end;

procedure forth_getuser2(vm:TKsanaForthVM);
begin
  vm.push(vm.user2);
end;
procedure forth_getuser3(vm:TKsanaForthVM);
begin
  vm.push(vm.user3);
end;
}
procedure corewords(vm:TKsanaForthVM);
begin

  vm.addcodeword('fence',integer(@forth_fence)); //// ( -- n )
  vm.addcodeword('(forget)',integer(@forth_pforget)); //// ( cfa -- f )
  vm.addcodeword('forget',integer(@forth_forget)); //// ( <word> -- )
  vm.addcodeword('anew',integer(@forth_anew)); //// ( <word> -- )
  vm.addcodeword('.last',integer(@forth_dotlast)); //// ( -- )
  vm.addcodeword('last',integer(@forth_last)); //// ( -- cfa )
  vm.addcodeword('[compile]',integer(@forth_bcompile),true); //// ( -- ) 
  vm.addcodeword('debug',integer(@forth_debug)); //// ( -- )
  vm.addcodeword('[debug]',integer(@forth_bdebug),true,true); //// ( -- )
  vm.addcodeword('''',integer(@forth_tick)); //// ( -- a )
  vm.addcodeword('link',integer(@forth_tolink)); //// ( cfa -- cfa' | 0 ) previouse word
  vm.addcodeword('>name',integer(@forth_toname)); //// ( cfa -- nfa )
  vm.addcodeword('.name',integer(@forth_dotname)); //// ( cfa -- )
  vm.addcodeword('.id',integer(@forth_ztype)); //// ( nfa -- )
  vm.addcodeword('bye',integer(@forth_bye));
  vm.addcodeword('esc',integer(@forth_esc)); //// ( -- $1B )
  vm.addcodeword('find',integer(@forth_find)); //// ( a n -- cfa | 0 )
  vm.addcodeword('execute',integer(@forth_execute)); //// ( cfa -- )
  vm.addcodeword('quitifmissing',integer(@forth_quitifmissing)); //// ( <name> -- )
  vm.addcodeword('iscode',integer(@forth_iscode)); //// ( cfa -- f )
  vm.addcodeword('depth',integer(@forth_depth)); //// ( -- n )
  vm.addcodeword('align',integer(@forth_align)); //// ( n -- n' ) adjust to cell boundary
{
  vm.addcodeword('user1!',integer(@forth_setuser1));
  vm.addcodeword('user2!',integer(@forth_setuser2));
  vm.addcodeword('user3!',integer(@forth_setuser3));
  vm.addcodeword('user1@',integer(@forth_getuser1));
  vm.addcodeword('user2@',integer(@forth_getuser2));
  vm.addcodeword('user3@',integer(@forth_getuser3));
}
  stackwords(vm);
  memorywords(vm);
  arithmeticwords(vm);
  structurewords(vm);
  compilerwords(vm);
  iowords(vm);
  osbindwords(vm);
end;

end.
